home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
JCSM Shareware Collection 1993 November
/
JCSM Shareware Collection - 1993-11.iso
/
cl720
/
qbnws31j.lzh
/
DEMO.BAS
< prev
next >
Wrap
BASIC Source File
|
1991-11-12
|
8KB
|
299 lines
'
' DEMO.BAS - demonstrates use of BIN files from
' Brent's QBASIC toolbox
'
' (C)1991 Brent Ashley
'
DEFINT A-Z
DECLARE SUB BiosPrint (Row%, Col%, Attr%, OutStr$)
DECLARE SUB BlockCopy (FromSeg%, FromOfs%, ToSeg%, ToOfs%, Count%)
DECLARE SUB Explode (Top%, Lft%, Bot%, Rgt%, Attr%, Shad%, Delay)
DECLARE SUB ScrnSave (SaveRestore%)
DECLARE SUB ScrollArea (Top%, Lft%, Bot%, Rgt%, Attr%, Lines%)
DECLARE SUB SLBox (Top%, Lft%, Bot%, Rgt%, Attr%, Shad%)
DECLARE SUB TickPause (Ticks%)
DECLARE FUNCTION ColorAttr% (Fore%, Back%)
DECLARE FUNCTION CurDir$ (DriveNum%)
DECLARE FUNCTION CurDrive% ()
DECLARE FUNCTION DayOfWeek% ()
DECLARE FUNCTION DosVer$ ()
DECLARE FUNCTION FileExist% (Filespec$)
DECLARE FUNCTION LoadBin$ (BinFileName$)
DECLARE FUNCTION WeekDay$ ()
TYPE RegTypeX
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
BP AS INTEGER
SI AS INTEGER
DI AS INTEGER
Flags AS INTEGER
DS AS INTEGER
ES AS INTEGER
END TYPE
DIM SHARED Regs AS RegTypeX
DECLARE SUB Interrupt (IntNum%, Regs AS RegTypeX)
CLS
' fill screen with letters
FOR i = 1 TO 24
PRINT STRING$(80, 64 + i);
NEXT
TickPause 9
' fancy scrolling
FOR i = 6 TO 15
ScrollArea 6, 25, 15, 55, ColorAttr(7, i), 1
TickPause 2
NEXT
TickPause 8
FOR i = 2 TO 23
ScrollArea 2, 2, 23, 79, ColorAttr(7, i), -1
TickPause 1
NEXT
TickPause 8
' panel and box
ScrollArea 5, 10, 21, 70, ColorAttr(0, 3), 0
SLBox 8, 30, 18, 47, ColorAttr(3, 0), 1
' quick color printing via BIOS
FOR i = 9 TO 17
BiosPrint i, 31, ColorAttr(23 - i, i), " Interrupt Demo "
NEXT
COLOR 31, 1: LOCATE 23, 32: PRINT " Press a key... ";
' save screen
ScrnSave 1
DO: LOOP UNTIL LEN(INKEY$)
CLS
' random boxes!
RANDOMIZE TIMER
FOR i = 1 TO 50
Top = 1 + RND(1) * 20
Lft = 1 + RND(1) * 70
Bot = Top + (23 - Top) * RND(1) + 1
Rgt = Lft + (77 - Lft) * RND(1) + 1
Fore = RND(1) * 15
Back = RND(1) * 8
SLBox Top, Lft, Bot, Rgt, ColorAttr(Fore, Back), 1
NEXT
COLOR 3, 0
SLBox 8, 25, 16, 55, ColorAttr(3, 0), 1
BiosPrint 10, 32, ColorAttr(19, 0), "50 Speedy Boxes!"
LOCATE 12, 32: PRINT " Press a key to"
LOCATE 13, 32: PRINT "see first screen"
LOCATE 14, 32: PRINT " again..."
DO: LOOP UNTIL LEN(INKEY$)
' restore screen
ScrnSave 0
DO: LOOP UNTIL LEN(INKEY$)
' show some system info
COLOR 14, 1
Attr = ColorAttr(14, 1)
Explode 5, 15, 17, 65, Attr, 0, 0
LOCATE 8, 23: PRINT " Today is: "; WeekDay$
LOCATE 9, 23: PRINT "Current Drive: "; CHR$(CurDrive + 64)
LOCATE 10, 23: PRINT " Directory: "; CurDir$(0)
LOCATE 11, 23: PRINT " Dos Version:"; DosVer$
IF FileExist("C:\CONFIG.SYS") THEN Sys$ = "Exists" ELSE Sys$ = "Not there"
LOCATE 12, 23: PRINT "C:\CONFIG.SYS: "; Sys$
IF FileExist("C:\QWERTY.UIO") THEN Sys$ = "Exists" ELSE Sys$ = "Not there"
LOCATE 13, 23: PRINT "C:\QWERTY.UIO: "; Sys$
ScrnSave 1
Explode 19, 20, 23, 60, Attr, 1, 3
LOCATE 21, 26: PRINT "Wow! - Pretty neat, Huh?!?"
TickPause 30
ScrnSave 0
DO: LOOP WHILE LEN(INKEY$) ' clear keyboard buffer
DO: LOOP UNTIL LEN(INKEY$)
COLOR 7, 0: CLS
PRINT "...end of demo."
SUB BiosPrint (Row, Col, Attr, OutStr$)
' print string using BIOS - only available on AT and later
Regs.AX = &H1301
Regs.BX = Attr
Regs.CX = LEN(OutStr$)
Regs.DX = (Row - 1) * 256 + (Col - 1)
Regs.ES = VARSEG(OutStr$)
Regs.BP = SADD(OutStr$)
Interrupt &H10, Regs
END SUB
SUB BlockCopy (FromSeg, FromOfs, ToSeg, ToOfs, Count)
STATIC MemCopy$
IF NOT LEN(MemCopy$) THEN MemCopy$ = LoadBin("MemCopy.BIN")
DEF SEG = VARSEG(MemCopy$)
CALL Absolute(FromSeg, FromOfs, ToSeg, ToOfs, Count, SADD(MemCopy$))
END SUB
FUNCTION ColorAttr (Fore, Back)
ColorAttr = (Fore AND 16) * 8 + (Back AND 7) * 16 + (Fore AND 15)
END FUNCTION
FUNCTION CurDir$ (DriveNum)
' returns current dir without leading \ or drive
' drive number is 0 for default, 1 for a, etc
STATIC Temp$
Temp$ = SPACE$(64)
Regs.AX = &H4700
Regs.DX = DriveNum
Regs.DS = VARSEG(Temp$)
Regs.SI = SADD(Temp$) ' use SADD for dynamic strings!
Interrupt &H21, Regs
CurDir$ = LEFT$(Temp$, INSTR(Temp$, CHR$(0)) - 1)
END FUNCTION
FUNCTION CurDrive
' returns logged drive (a=1, b=2, etc)
Regs.AX = &H1900
Interrupt &H21, Regs
CurDrive = Regs.AX MOD 256 + 1
END FUNCTION
FUNCTION DosVer$
' returns DOS version in string format
Regs.AX = &H3000
Interrupt &H21, Regs
DosVer$ = RTRIM$(STR$(Regs.AX MOD 256)) + "." + LTRIM$(STR$(Regs.AX \ 256))
END FUNCTION
SUB Explode (Top, Lft, Bot, Rgt, Attr, Shad, Delay)
Wide = Rgt - Lft
High = Bot - Top
HMid = (Rgt + Lft) \ 2
VMid = (Top + Bot) \ 2
FOR i = 1 TO High \ 2
HOfs = i * (Wide / High)
IF HOfs >= 1 THEN
SLBox VMid - i, HMid - HOfs, VMid + i, HMid + HOfs, Attr, 0
END IF
TickPause Delay
NEXT
SLBox Top, Lft, Bot, Rgt, Attr, Shad
END SUB
FUNCTION FileExist (Filespec$) STATIC
' set new DOS DTA
DIM DTA AS STRING * 43
DTA = SPACE$(43)
Regs.AX = &H1A00
Regs.DS = VARSEG(DTA)
Regs.DX = VARPTR(DTA)
Interrupt &H21, Regs
' insulate Filespec from change
Spec$ = Filespec$ + CHR$(0)
Regs.AX = &H4E00
Regs.CX = 39
Regs.DS = VARSEG(Spec$)
Regs.DX = SADD(Spec$)
Interrupt &H21, Regs
IF Regs.Flags AND 1 THEN FileExist = 0 ELSE FileExist = -1
END FUNCTION
SUB Interrupt (IntNum, Regs AS RegTypeX) STATIC
STATIC FileNum, IntOffset, Loaded
' use fixed-length string to fix its position in memory
' and so we don't mess up string pool before routine
' gets its pointers from caller
DIM IntCode AS STRING * 200
IF NOT Loaded THEN ' loaded will be 0 first time
IntCode = LoadBin("IntCode.BIN") ' load routine and determine
IntOffset = INSTR(IntCode$, CHR$(&HCD) + CHR$(&H21)) + 1 ' int # offset
Loaded = -1
END IF
SELECT CASE IntNum
CASE &H25, &H26, IS > 255 ' ignore these interrupts
CASE ELSE
DEF SEG = VARSEG(IntCode) ' poke interrupt number into
POKE VARPTR(IntCode) * 1& + IntOffset - 1, IntNum' code block
CALL Absolute(Regs, VARPTR(IntCode$)) ' call routine
END SELECT
END SUB
FUNCTION LoadBin$ (BinFileName$)
' Loads a binary file as a string
STATIC FileNum, Buf$
FileNum = FREEFILE
OPEN BinFileName$ FOR BINARY AS FileNum
IF LOF(FileNum) = 0 THEN
CLOSE FileNum
KILL BinFileName$
CLS : PRINT "Can't find "; BinFileName$; " - aborting."
END
END IF
Buf$ = SPACE$(LOF(FileNum)) ' size buffer
GET FileNum, , Buf$
CLOSE #FileNum
LoadBin$ = Buf$
END FUNCTION
SUB ScrnSave (SaveRestore) STATIC
STATIC InitDone
IF NOT InitDone THEN
REDIM ScrnBuf(1 TO 2000) ' 4000 bytes
DEF SEG = 0
IF PEEK(&H463) = &HB4 THEN
VidSeg = &HB000 ' mono
ELSE
VidSeg = &HB800 ' color
END IF
InitDone = -1
END IF
IF SaveRestore THEN ' save
BlockCopy VidSeg, 0, VARSEG(ScrnBuf(1)), VARPTR(ScrnBuf(1)), 4000
ELSE
BlockCopy VARSEG(ScrnBuf(1)), VARPTR(ScrnBuf(1)), VidSeg, 0, 4000
END IF
END SUB
SUB ScrollArea (Top, Lft, Bot, Rgt, Attr, Lines)
' scrolls area up (or down if lines negative)
' scrolled away area filled with Attr
' use lines = 0 to clear entire area to Attr
IF Lines > 0 THEN
Regs.AX = &H600 + Lines
ELSE
Regs.AX = &H700 - Lines
END IF
Regs.BX = Attr * 256
Regs.CX = (Top - 1) * 256 + Lft - 1
Regs.DX = (Bot - 1) * 256 + Rgt - 1
Interrupt &H10, Regs
END SUB
SUB SLBox (Top, Lft, Bot, Rgt, Attr, Shad)
STATIC SLB$, BinLoaded
IF NOT BinLoaded THEN
SLB$ = LoadBin("SLBox.BIN")
BinLoaded = -1
END IF
DEF SEG = VARSEG(SLB$)
CALL Absolute(Top, Lft, Bot, Rgt, Attr, Shad, SADD(SLB$))
END SUB
SUB TickPause (Ticks)
DEF SEG = 0
FOR i = 1 TO Ticks
Now = PEEK(&H46C)
DO: LOOP WHILE PEEK(&H46C) = Now
NEXT
END SUB
FUNCTION WeekDay$
Regs.AX = &H2A00
Interrupt &H21, Regs
SELECT CASE Regs.AX MOD 256 + 1
CASE 1: WeekDay$ = "Sunday"
CASE 2: WeekDay$ = "Monday"
CASE 3: WeekDay$ = "Tuesday"
CASE 4: WeekDay$ = "Wednesday"
CASE 5: WeekDay$ = "Thursday"
CASE 6: WeekDay$ = "Friday"
CASE 7: WeekDay$ = "Saturday"
END SELECT
END FUNCTION